home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / generic / vm-fndb.lisp < prev    next >
Encoding:
Text File  |  1992-05-22  |  9.7 KB  |  319 lines
  1. ;;; -*- Package: C; Log: C.Log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: /afs/cs.cmu.edu/project/clisp/src/16/compiler/generic/RCS/vm-fndb.lisp,v 1.42 92/03/07 17:14:17 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; $Header: /afs/cs.cmu.edu/project/clisp/src/16/compiler/generic/RCS/vm-fndb.lisp,v 1.42 92/03/07 17:14:17 wlott Exp $
  15. ;;;
  16. ;;; This file defines the machine specific function signatures.
  17. ;;;
  18. ;;; Written by William Lott.
  19. ;;;
  20. (in-package "C")
  21.  
  22. (import '(lisp::%raw-bits lisp::simple-array-p))
  23.  
  24. (in-package "KERNEL")
  25. (export '(current-sp current-fp 
  26.       stack-ref %set-stack-ref lra-code-header
  27.       function-code-header make-lisp-obj get-lisp-obj-address
  28.       function-word-offset code-debug-info
  29.       funcallable-instance-p %set-funcallable-instance-info
  30.       code-header-ref code-header-set code-instructions
  31.       shift-towards-start shift-towards-end
  32.  
  33.       32bit-logical-not
  34.       32bit-logical-and 32bit-logical-nand
  35.       32bit-logical-or 32bit-logical-nor
  36.       32bit-logical-xor 32bit-logical-eqv
  37.       32bit-logical-andc1 32bit-logical-andc2
  38.       32bit-logical-orc1 32bit-logical-orc2
  39.  
  40.       mutator-self))
  41.  
  42. (in-package "C")
  43.  
  44.  
  45. ;;;; Internal type predicates:
  46. ;;;
  47. ;;;    Simple typep uses that don't have any standard predicate are translated
  48. ;;; into non-standard unary predicates.
  49.  
  50. (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
  51.        long-float-p base-char-p %string-char-p %standard-char-p structurep
  52.        array-header-p simple-array-p simple-array-unsigned-byte-2-p
  53.        simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
  54.        simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
  55.        simple-array-single-float-p simple-array-double-float-p
  56.        system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p
  57.        weak-pointer-p scavenger-hook-p code-component-p lra-p
  58.        funcallable-instance-p)
  59.   (t) boolean (movable foldable flushable))
  60.  
  61.  
  62. ;;;; Miscellaneous "sub-primitives":
  63.  
  64. (defknown %sp-string-compare
  65.   (simple-string index index simple-string index index)
  66.   (or index null)
  67.   (foldable flushable))
  68.  
  69. (defknown %sxhash-simple-string (simple-string) index
  70.   (foldable flushable))
  71.  
  72. (defknown %sxhash-simple-substring (simple-string index) index
  73.   (foldable flushable))
  74.  
  75.  
  76. (defknown %closure-index-ref (function index) t
  77.   (flushable))
  78.  
  79.  
  80. (defknown %make-funcallable-instance (index function) function (unsafe))
  81.  
  82. (defknown %set-funcallable-instance-info (function index t) t (unsafe))
  83.  
  84.  
  85. (defknown vector-sap ((simple-unboxed-array (*))) system-area-pointer
  86.   (flushable))
  87.  
  88.  
  89. (defknown get-lowtag (t) (unsigned-byte #.vm:lowtag-bits)
  90.   (flushable movable))
  91. (defknown get-type (t) (unsigned-byte #.vm:type-bits)
  92.   (flushable movable))
  93.  
  94. (defknown (get-header-data get-closure-length) (t) (unsigned-byte 24)
  95.   (flushable))
  96. (defknown set-header-data (t (unsigned-byte 24)) t
  97.   (unsafe))
  98.  
  99.  
  100. (defknown make-structure (structure-index) structure
  101.   (unsafe))
  102. (defknown structure-type (structure) t
  103.   (foldable flushable))
  104. (defknown structure-length (structure) structure-index
  105.   (foldable flushable))
  106. (defknown structure-ref (structure structure-index) t
  107.   (flushable))
  108. (defknown structure-set (structure structure-index t) t
  109.   (unsafe))
  110.  
  111.  
  112.  
  113. (defknown %raw-bits (t fixnum) (unsigned-byte 32)
  114.   (foldable flushable))
  115. (defknown (%set-raw-bits) (t fixnum (unsigned-byte 32)) (unsigned-byte 32)
  116.   (unsafe))
  117.  
  118.  
  119. (defknown allocate-vector ((unsigned-byte 8) index index) (simple-array * (*))
  120.   (flushable movable))
  121.  
  122. (defknown make-array-header ((unsigned-byte 8) (unsigned-byte 24)) array
  123.   (flushable movable))
  124.  
  125.  
  126. (defknown %make-weak-pointer (t boolean) weak-pointer
  127.   (flushable))
  128. (defknown %make-scavenger-hook (t function) scavenger-hook
  129.   (flushable))
  130. (defknown %make-complex (real real) complex
  131.   (flushable movable))
  132. (defknown %make-ratio (rational rational) ratio
  133.   (flushable movable))
  134. (defknown make-value-cell (t) t
  135.   (flushable movable))
  136.  
  137. (defknown (dynamic-space-free-pointer binding-stack-pointer-sap
  138.                       control-stack-pointer-sap)  ()
  139.   system-area-pointer
  140.   (flushable))
  141.  
  142.  
  143.  
  144. ;;;; Debugger support:
  145.  
  146. (defknown current-sp () system-area-pointer (movable flushable))
  147. (defknown current-fp () system-area-pointer (movable flushable))
  148. (defknown stack-ref (system-area-pointer index) t (flushable))
  149. (defknown %set-stack-ref (system-area-pointer index t) t (unsafe))
  150. (defknown lra-code-header (t) t (movable flushable))
  151. (defknown function-code-header (t) t (movable flushable))
  152. (defknown make-lisp-obj ((unsigned-byte 32)) t (movable flushable))
  153. (defknown get-lisp-obj-address (t) (unsigned-byte 32) (movable flushable))
  154. (defknown function-word-offset (function) index (movable flushable))
  155.  
  156.  
  157. ;;;; 32bit logical operations
  158.  
  159. (defknown merge-bits ((unsigned-byte 5) (unsigned-byte 32) (unsigned-byte 32))
  160.   (unsigned-byte 32)
  161.   (foldable flushable movable))
  162.  
  163. (defknown 32bit-logical-not ((unsigned-byte 32)) (unsigned-byte 32)
  164.   (foldable flushable movable))
  165.  
  166. (defknown (32bit-logical-and 32bit-logical-nand
  167.        32bit-logical-or 32bit-logical-nor
  168.        32bit-logical-xor 32bit-logical-eqv
  169.        32bit-logical-andc1 32bit-logical-andc2
  170.        32bit-logical-orc1 32bit-logical-orc2)
  171.       ((unsigned-byte 32) (unsigned-byte 32)) (unsigned-byte 32)
  172.   (foldable flushable movable))
  173.  
  174.  
  175. (defknown (shift-towards-start shift-towards-end) ((unsigned-byte 32) fixnum)
  176.   (unsigned-byte 32)
  177.   (foldable flushable movable))
  178.  
  179.  
  180.  
  181. ;;;; Bignum operations.
  182.  
  183. (defknown %allocate-bignum (bignum-index) bignum-type
  184.   (flushable))
  185.  
  186. (defknown %bignum-length (bignum-type) bignum-index
  187.   (foldable flushable movable))
  188.  
  189. (defknown %bignum-set-length (bignum-type bignum-index) bignum-type
  190.   (unsafe))
  191.  
  192. (defknown %bignum-ref (bignum-type bignum-index) bignum-element-type
  193.   (flushable))
  194.  
  195. (defknown %bignum-set (bignum-type bignum-index bignum-element-type)
  196.   bignum-element-type
  197.   (unsafe))
  198.  
  199. (defknown %digit-0-or-plusp (bignum-element-type) boolean
  200.   (foldable flushable movable))
  201.  
  202. (defknown (%add-with-carry %subtract-with-borrow)
  203.       (bignum-element-type bignum-element-type (mod 2))
  204.   (values bignum-element-type (mod 2))
  205.   (foldable flushable movable))
  206.  
  207. (defknown %multiply-and-add
  208.       (bignum-element-type bignum-element-type bignum-element-type
  209.                    &optional bignum-element-type)
  210.   (values bignum-element-type bignum-element-type)
  211.   (foldable flushable movable))
  212.  
  213. (defknown %multiply (bignum-element-type bignum-element-type)
  214.   (values bignum-element-type bignum-element-type)
  215.   (foldable flushable movable))
  216.  
  217. (defknown %lognot (bignum-element-type) bignum-element-type
  218.   (foldable flushable movable))
  219.  
  220. (defknown (%logand %logior %logxor) (bignum-element-type bignum-element-type)
  221.   bignum-element-type
  222.   (foldable flushable movable))
  223.  
  224. (defknown %fixnum-to-digit (fixnum) bignum-element-type
  225.   (foldable flushable movable))
  226.  
  227. (defknown %floor (bignum-element-type bignum-element-type bignum-element-type)
  228.   (values bignum-element-type bignum-element-type)
  229.   (foldable flushable movable))
  230.  
  231. (defknown %fixnum-digit-with-correct-sign (bignum-element-type)
  232.   (signed-byte #.vm:word-bits)
  233.   (foldable flushable movable))
  234.  
  235. (defknown (%ashl %ashr %digit-logical-shift-right)
  236.       (bignum-element-type (mod 32)) bignum-element-type
  237.   (foldable flushable movable))
  238.  
  239.  
  240. ;;;; Bit-bashing routines.
  241.  
  242. (defknown copy-to-system-area
  243.       ((simple-unboxed-array (*)) index system-area-pointer index index)
  244.   null
  245.   ())
  246.  
  247. (defknown copy-from-system-area
  248.       (system-area-pointer index (simple-unboxed-array (*)) index index)
  249.   null
  250.   ())
  251.  
  252. (defknown system-area-copy
  253.       (system-area-pointer index system-area-pointer index index)
  254.   null
  255.   ())
  256.  
  257. (defknown bit-bash-copy
  258.       ((simple-unboxed-array (*)) index
  259.        (simple-unboxed-array (*)) index index)
  260.   null
  261.   ())
  262.  
  263.  
  264. ;;;; Code/function/fdefn object manipulation routines.
  265.  
  266. (defknown code-instructions (t) system-area-pointer (flushable movable))
  267. (defknown code-header-ref (t index) t (flushable))
  268. (defknown code-header-set (t index t) t ())
  269.  
  270. (defknown make-fdefn (t) fdefn (flushable movable))
  271. (defknown fdefn-p (t) boolean (movable foldable flushable))
  272. (defknown fdefn-name (fdefn) t (foldable flushable))
  273. (defknown fdefn-function (fdefn) (or function null) (flushable))
  274. (defknown (setf fdefn-function) (function fdefn) t (unsafe))
  275. (defknown fdefn-makunbound (fdefn) t ())
  276.  
  277.  
  278.  
  279. ;;;; Mutator accessors.
  280.  
  281. (defknown mutator-self () system-area-pointer (flushable movable))
  282.  
  283.  
  284.  
  285. ;;;; Automatic defknowns for primitive objects.
  286.  
  287. (vm:define-for-each-primitive-object (obj)
  288.   (collect ((forms))
  289.     (let* ((options (vm:primitive-object-options obj))
  290.        (obj-type (getf options :type t)))
  291.       (dolist (slot (vm:primitive-object-slots obj))
  292.     (let* ((name (vm:slot-name slot))
  293.            (slot-opts (vm:slot-options slot))
  294.            (slot-type (getf slot-opts :type t))
  295.            (ref-trans (getf slot-opts :ref-trans))
  296.            (ref-known (getf slot-opts :ref-known))
  297.            (set-trans (getf slot-opts :set-trans))
  298.            (set-known (getf slot-opts :set-known)))
  299.       (when ref-known
  300.         (if ref-trans
  301.         (forms `(defknown (,ref-trans) (,obj-type) ,slot-type
  302.               ,ref-known))
  303.         (error "Can't spec a :ref-known with no :ref-trans. ~S in ~S"
  304.                name (vm:primitive-object-name obj))))
  305.       (when set-known
  306.         (if set-trans
  307.         (forms `(defknown (,set-trans)
  308.                   ,(if (and (listp set-trans)
  309.                         (= (length set-trans) 2)
  310.                         (eq (car set-trans) 'setf))
  311.                        (list slot-type obj-type)
  312.                        (list obj-type slot-type))
  313.               ,slot-type ,set-known))
  314.         (error "Can't spec a :set-known with no :set-trans. ~S in ~S"
  315.                name (vm:primitive-object-name obj)))))))
  316.     (when (forms)
  317.       `(progn
  318.      ,@(forms)))))
  319.